home *** CD-ROM | disk | FTP | other *** search
/ Technotools / Technotools (Chestnut CD-ROM)(1993).ISO / lang_oth / ada / disgusta.pas < prev    next >
Pascal/Delphi Source File  |  1985-10-29  |  9KB  |  262 lines
  1. Program DisGusta;
  2. { This program is a disassembler for p-code programs produced with }
  3. {  the public domain Augusta Ada subset compiler. }
  4.  
  5. {$R+ } { turn on subscript and type checking }
  6.  
  7. Const
  8.   dis_version = '1.0';
  9.   nl          = #13#10; {characters to start a new line }
  10. Type
  11.   String5     = string[5];
  12. Var
  13.   header    : record
  14.                 code_size  : integer; {code size in bytes}
  15.                 max_record : integer; {number of 128-byte records in the file }
  16.                 max_proc   : integer; {number of procedures }
  17.                 version    : integer; {code file version number}
  18.               end;
  19.   proctable : array[1..256] of record
  20.                 offset          : integer; { offset from CS to proc code}
  21.                 local_var_bytes : integer; { # of bytes needed for local vars }
  22.                 parm_bytes      : integer; { # of bytes needed for parameters }
  23.                 level           : byte;    { lexical level of the procedure }
  24.               end;
  25.   code_file                     : file of byte; { the program file }
  26.   listing                       : text;         { the listing file }
  27.   Z,CP                          : integer; { work variables }
  28.  
  29.  
  30. Procedure Load_Program;
  31. { gets the name of the p-code file, opens it, and reads in the }
  32. {  header and procedure table; opens the listing file. }
  33. var
  34.   name          : string[32]; { filename }
  35.   temp1,temp2   : byte;       { work variables }
  36.   temp3,temp4   : byte;
  37.   I             : integer;
  38.   N             : string[1];
  39.   error,original: boolean;    { true when an error occured somewhere }
  40. begin
  41.   { loop through the opening process until a valid file is found }
  42.   Repeat
  43.    error := false;
  44.  
  45.   { present the intro screen }
  46.   clrscr; writeln('D i s g u s t a',nl,'Version ',dis_version);
  47.  
  48.   { get the filename and make sure it's available }
  49.   repeat
  50.     sound(660); delay(300); nosound;
  51.     write(nl,'Input filename ? ');
  52.     {$I-} readln(name); assign(code_file,name); reset(code_file); {$I+}
  53.   until IOResult=0;
  54.  
  55.   { load the header block and make sure it's an augusta code file }
  56.   with header do begin
  57.     read(code_file, temp1,temp2,temp3,temp4);
  58.     code_size := temp2*256 + temp1 - 1920;
  59.     max_record := temp4*256 + temp3;
  60.     read(code_file, temp1,temp2,temp3,temp4);
  61.     max_proc := temp2*256 + temp1; version := temp4*256 + temp3;
  62.   end;
  63.   read(code_file, temp1,temp2,temp3,temp4);
  64.   if not ((temp1=89) and (temp2=4) and (temp3=0) and (temp4=0))
  65.      or (filesize(code_file)<1921) then begin
  66.     writeln(name,' is not a valid Augusta p-code file.');
  67.     delay(1000); error := true;
  68.     end
  69.  
  70.   { read in only as many proc table entries as  the header says exist }
  71.   else begin
  72.     seek(code_file,128);{ skip 116 unused header bytes to the proc table}
  73.     for I:=1 to header.max_proc do
  74.       with proctable[i] do begin
  75.         read(code_file, temp1,temp2,temp3,temp4);
  76.         offset := (temp2 shl 8) + temp1;
  77.         local_var_bytes := (temp4 shl 8) + temp3;
  78.         read(code_file, temp1,temp2,level);
  79.         parm_bytes := (temp2 shl 8) + temp1;
  80.       end;
  81.   end;
  82.   close(code_file);
  83.   Until error=false;
  84.  
  85.   { leave the code file open now that we know it's legal }
  86.   assign(code_file,name); reset(code_file);
  87.   { find an original name for the listing file }
  88.   Z := pos('.',name);
  89.   if Z>0 then delete(name,Z,31);
  90.   name := name + '.dis';
  91.   {$I-}
  92.     Z := 0;
  93.     repeat
  94.       assign(listing,name); reset(listing);
  95.       if ioresult<>0 then
  96.         original := true
  97.       else begin
  98.         close(listing);
  99.         str(Z,N);
  100.         name[length(name)] := N;
  101.         Z := Z + 1;
  102.         original := false;
  103.       end;
  104.     until original or (Z>9);
  105.   {$I+}
  106.   assign(listing,name); rewrite(listing);
  107.   writeln(nl,'Listing file will be named ',#39,name,#39);
  108. end;
  109.  
  110. Function Get_byte(var offset: integer): integer;
  111. { gets the byte at Offset into Byte1 and increments Offset to the next byte }
  112. var
  113.   ch: byte;
  114. begin
  115.   offset := offset + 1; read(code_file,ch); get_byte := ch;
  116. end;
  117.  
  118. Function Get_Word(offset: integer): integer;
  119. { gets the word at Offset, leaving Offset as it was on entry }
  120. var
  121.   ch,ch2: byte;
  122. begin
  123.   read(code_file,ch,ch2); get_word := ch + (ch2 shl 8);
  124. end;
  125.  
  126. Procedure Interpret_Code;
  127. { interprets the op-code in byte1, using additional bytes and }
  128. { adjusting CP accordingly. }
  129. var
  130.   byte1         : byte;    { gets the op-code byte }
  131.   temp1,temp2,I : integer; { local work variables }
  132.  
  133.   procedure Load_Or_Store;
  134.   begin
  135.     temp2 := get_word(CP);
  136.     case byte1 of
  137.       1: writeln(listing,'LDCI ',temp2);
  138.       2: writeln(listing,'LDL ',temp2);
  139.       3: writeln(listing,'LLA ',temp2);
  140.       4: begin writeln(listing,'LDB'); CP := CP - 2; end;
  141.       5: writeln(listing,'LDO ',temp2);
  142.       6: writeln(listing,'LAO ',temp2);
  143.       8: begin
  144.            temp1 := get_byte(CP);
  145.            writeln(listing,'LOD ',temp1,' ',temp2);
  146.          end;
  147.       9: begin
  148.            temp1 := get_byte(CP);
  149.            writeln(listing,'LOA ',temp1,' ',temp2);
  150.          end;
  151.     end;
  152.     CP := CP + 2;
  153.   end; { load_or_store }
  154.  
  155.   Procedure Jump;
  156.   begin
  157.     temp1 := get_word(CP); CP := CP + 2;
  158.     case byte1 of
  159.       37: writeln(listing,'UJP ',temp1,' -> ',(temp1+CP));
  160.       38: writeln(listing,'FJP ',temp1,' -> ',(temp1+CP));
  161.       39: begin
  162.             temp2 := get_word(CP); I := get_word(CP+2);
  163.             writeln(listing,'XJP ',temp1,',',temp2,' ',I,' -> ',(I+CP));
  164.             CP := CP + 4;
  165.           end;
  166.     end;
  167.   end;
  168.  
  169. begin
  170.   { get an op-code byte from the buffer }
  171.   byte1 := get_byte(CP);
  172.   write(listing,(CP-1):5,':  ',byte1:6,'    ');
  173.  
  174.   case byte1 of               { Note- indented procedures are repeats from }
  175.      1..10: load_or_store;    {  a previous line. }
  176.         11: writeln(listing,'STO');
  177.         12: writeln(listing,'SINDO');
  178.         13: begin
  179.               temp1 := get_byte(CP);
  180.               write(listing,'LCA ',temp1,#32#39);
  181.               while temp1>0 do begin
  182.                 temp2 := get_byte(CP);
  183.                 write(listing,char(temp2)); temp1 := temp1 - 1;
  184.               end;
  185.               writeln(listing,#39);
  186.             end;
  187.         14: writeln(listing,'SAS');
  188.         15: begin
  189.               writeln(listing,'EOP'); CP := -1; { flag CP on end-of-proc }
  190.             end;
  191.         16: writeln(listing,'AND');
  192.         17: writeln(listing,'OR');
  193.         18: writeln(listing,'NOT');
  194.         19: writeln(listing,'ADI');
  195.         20: writeln(listing,'NGI');
  196.         21: writeln(listing,'SBI');
  197.         22: writeln(listing,'MPI');
  198.         23: writeln(listing,'DVI');
  199.         24: writeln(listing,'IND');
  200.         25: writeln(listing,'EQUI');
  201.         26: writeln(listing,'NEQI');
  202.         27: writeln(listing,'LEQI');
  203.         28: writeln(listing,'LESI');
  204.         29: writeln(listing,'GEQI');
  205.         30: writeln(listing,'GTRI');
  206.         31: writeln(listing,'EQUSTR');
  207.         32: writeln(listing,'NEQSTR');
  208.         33: writeln(listing,'LEQSTR');
  209.         34: writeln(listing,'LESSTR');
  210.         35: writeln(listing,'GEQSTR');
  211.         36: writeln(listing,'GTRSTR');
  212.     37..39: jump;
  213.         40: begin temp1 := get_byte(CP); writeln(listing,'CLP ',temp1); end;
  214.         41: begin temp1 := get_byte(CP); writeln(listing,'CGP ',temp1); end;
  215.         43: writeln(listing,'RET');
  216.         45: writeln(listing,'MODI');
  217.         46: writeln(listing,'RNP');
  218.         42: begin temp1 := get_byte(CP); writeln(listing,'CSP ',temp1); end;
  219.         47: writeln(listing,'RNP');
  220.         48: begin temp1 := get_byte(CP); writeln(listing,'IXA ',temp1); end;
  221.     49..56: writeln(listing,'SLDL',(byte1-49));
  222.         57: begin temp1 := get_byte(CP); writeln(listing,'SLDO ',temp1); end;
  223.         58: begin temp1 := get_byte(CP); writeln(listing,'SLAO ',temp1); end;
  224.         59: begin temp1 := get_byte(CP); writeln(listing,'SLLA ',temp1); end;
  225.         60: begin temp1 := get_byte(CP); writeln(listing,'SLDL ',temp1); end;
  226.         61: begin temp1 := get_byte(CP); writeln(listing,'SLDC ',temp1); end;
  227.         63: writeln(listing,'SLDCN1');
  228.     64..79: writeln(listing,'SLDC',(byte1-64));
  229.         80: begin
  230.               temp1 := get_word(CP);
  231.               writeln(listing,'INCL ',temp1); CP := CP + 2;
  232.             end;
  233.         81: begin
  234.               temp1 := get_word(CP);
  235.               writeln(listing,'DECL ',temp1); CP := CP + 2;
  236.             end;
  237.       else  writeln(listing,'???');
  238.   end;
  239. end;
  240.  
  241. BEGIN
  242.  
  243.   load_program;
  244.   Z := 0;
  245.   while Z<header.max_proc do begin
  246.     Z := Z + 1;
  247.     writeln(listing,nl,'Procedure ',Z);
  248.     with proctable[Z] do begin
  249.       writeln(listing,'   Offset=',offset,', ',local_var_bytes,
  250.         ' bytes local variables, ',parm_bytes,' bytes parameters, Level ',
  251.         level,nl);
  252.       CP := offset; seek(code_file,CP+1920);
  253.     end;
  254.     writeln(listing,'Offset   Opcode   Mnemonic (and parameters)');
  255.     while CP>-1 do interpret_code;
  256.   end;
  257.   writeln(listing);
  258.   close(code_file);
  259.   close(listing);
  260.  
  261. END.
  262.